home *** CD-ROM | disk | FTP | other *** search
/ Mac Easy 2010 May / Mac Life Ubuntu.iso / casper / filesystem.squashfs / usr / share / guile / 1.8 / srfi / srfi-17.scm < prev    next >
Encoding:
Text File  |  2008-12-17  |  6.4 KB  |  175 lines
  1. ;;; srfi-17.scm --- Generalized set!
  2.  
  3. ;; Copyright (C) 2001, 2002, 2003, 2006 Free Software Foundation, Inc.
  4. ;;
  5. ;; This library is free software; you can redistribute it and/or
  6. ;; modify it under the terms of the GNU Lesser General Public
  7. ;; License as published by the Free Software Foundation; either
  8. ;; version 2.1 of the License, or (at your option) any later version.
  9. ;; 
  10. ;; This library is distributed in the hope that it will be useful,
  11. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13. ;; Lesser General Public License for more details.
  14. ;; 
  15. ;; You should have received a copy of the GNU Lesser General Public
  16. ;; License along with this library; if not, write to the Free Software
  17. ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18.  
  19. ;;; Author: Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de>
  20.  
  21. ;;; Commentary:
  22.  
  23. ;; This is an implementation of SRFI-17: Generalized set!
  24. ;;
  25. ;; It exports the Guile procedure `make-procedure-with-setter' under
  26. ;; the SRFI name `getter-with-setter' and exports the standard
  27. ;; procedures `car', `cdr', ..., `cdddr', `string-ref' and
  28. ;; `vector-ref' as procedures with setters, as required by the SRFI.
  29. ;;
  30. ;; SRFI-17 was heavily criticized during its discussion period but it
  31. ;; was finalized anyway.  One issue was its concept of globally
  32. ;; associating setter "properties" with (procedure) values, which is
  33. ;; non-Schemy.  For this reason, this implementation chooses not to
  34. ;; provide a way to set the setter of a procedure.  In fact, (set!
  35. ;; (setter PROC) SETTER) signals an error.  The only way to attach a
  36. ;; setter to a procedure is to create a new object (a "procedure with
  37. ;; setter") via the `getter-with-setter' procedure. This procedure is
  38. ;; also specified in the SRFI.  Using it avoids the described
  39. ;; problems.
  40. ;;
  41. ;; This module is fully documented in the Guile Reference Manual.
  42.  
  43. ;;; Code:
  44.  
  45. (define-module (srfi srfi-17)
  46.   :export (getter-with-setter)
  47.   :replace (;; redefined standard procedures
  48.         setter
  49.         car cdr caar cadr cdar cddr caaar caadr cadar caddr cdaar
  50.         cdadr cddar cdddr caaaar caaadr caadar caaddr cadaar cadadr
  51.         caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr
  52.         cdddar cddddr string-ref vector-ref))
  53.  
  54. (cond-expand-provide (current-module) '(srfi-17))
  55.  
  56. ;;; Procedures
  57.  
  58. (define getter-with-setter make-procedure-with-setter)
  59.  
  60. (define setter
  61.   (getter-with-setter
  62.    (@ (guile) setter)
  63.    (lambda args
  64.      (error "Setting setters is not supported for a good reason."))))
  65.  
  66. ;;; Redefine R5RS procedures to appropriate procedures with setters
  67.  
  68. (define (compose-setter setter location)
  69.   (lambda (obj value)
  70.     (setter (location obj) value)))
  71.  
  72. (define car
  73.   (getter-with-setter (@ (guile) car)
  74.                       set-car!))
  75. (define cdr
  76.   (getter-with-setter (@ (guile) cdr)
  77.                       set-cdr!))
  78.  
  79. (define caar
  80.   (getter-with-setter (@ (guile) caar)
  81.                       (compose-setter set-car! (@ (guile) car))))
  82. (define cadr
  83.   (getter-with-setter (@ (guile) cadr)
  84.                       (compose-setter set-car! (@ (guile) cdr))))
  85. (define cdar
  86.   (getter-with-setter (@ (guile) cdar)
  87.                       (compose-setter set-cdr! (@ (guile) car))))
  88. (define cddr
  89.   (getter-with-setter (@ (guile) cddr)
  90.                       (compose-setter set-cdr! (@ (guile) cdr))))
  91.  
  92. (define caaar
  93.   (getter-with-setter (@ (guile) caaar)
  94.                       (compose-setter set-car! (@ (guile) caar))))
  95. (define caadr
  96.   (getter-with-setter (@ (guile) caadr)
  97.                       (compose-setter set-car! (@ (guile) cadr))))
  98. (define cadar
  99.   (getter-with-setter (@ (guile) cadar)
  100.                       (compose-setter set-car! (@ (guile) cdar))))
  101. (define caddr
  102.   (getter-with-setter (@ (guile) caddr)
  103.                       (compose-setter set-car! (@ (guile) cddr))))
  104. (define cdaar
  105.   (getter-with-setter (@ (guile) cdaar)
  106.                       (compose-setter set-cdr! (@ (guile) caar))))
  107. (define cdadr
  108.   (getter-with-setter (@ (guile) cdadr)
  109.                       (compose-setter set-cdr! (@ (guile) cadr))))
  110. (define cddar
  111.   (getter-with-setter (@ (guile) cddar)
  112.                       (compose-setter set-cdr! (@ (guile) cdar))))
  113. (define cdddr
  114.   (getter-with-setter (@ (guile) cdddr)
  115.                       (compose-setter set-cdr! (@ (guile) cddr))))
  116.  
  117. (define caaaar
  118.   (getter-with-setter (@ (guile) caaaar)
  119.                       (compose-setter set-car! (@ (guile) caaar))))
  120. (define caaadr
  121.   (getter-with-setter (@ (guile) caaadr)
  122.                       (compose-setter set-car! (@ (guile) caadr))))
  123. (define caadar
  124.   (getter-with-setter (@ (guile) caadar)
  125.                       (compose-setter set-car! (@ (guile) cadar))))
  126. (define caaddr
  127.   (getter-with-setter (@ (guile) caaddr)
  128.                       (compose-setter set-car! (@ (guile) caddr))))
  129. (define cadaar
  130.   (getter-with-setter (@ (guile) cadaar)
  131.                       (compose-setter set-car! (@ (guile) cdaar))))
  132. (define cadadr
  133.   (getter-with-setter (@ (guile) cadadr)
  134.                       (compose-setter set-car! (@ (guile) cdadr))))
  135. (define caddar
  136.   (getter-with-setter (@ (guile) caddar)
  137.                       (compose-setter set-car! (@ (guile) cddar))))
  138. (define cadddr
  139.   (getter-with-setter (@ (guile) cadddr)
  140.                       (compose-setter set-car! (@ (guile) cdddr))))
  141. (define cdaaar
  142.   (getter-with-setter (@ (guile) cdaaar)
  143.                       (compose-setter set-cdr! (@ (guile) caaar))))
  144. (define cdaadr
  145.   (getter-with-setter (@ (guile) cdaadr)
  146.                       (compose-setter set-cdr! (@ (guile) caadr))))
  147. (define cdadar
  148.   (getter-with-setter (@ (guile) cdadar)
  149.                       (compose-setter set-cdr! (@ (guile) cadar))))
  150. (define cdaddr
  151.   (getter-with-setter (@ (guile) cdaddr)
  152.                       (compose-setter set-cdr! (@ (guile) caddr))))
  153. (define cddaar
  154.   (getter-with-setter (@ (guile) cddaar)
  155.                       (compose-setter set-cdr! (@ (guile) cdaar))))
  156. (define cddadr
  157.   (getter-with-setter (@ (guile) cddadr)
  158.                       (compose-setter set-cdr! (@ (guile) cdadr))))
  159. (define cdddar
  160.   (getter-with-setter (@ (guile) cdddar)
  161.                       (compose-setter set-cdr! (@ (guile) cddar))))
  162. (define cddddr
  163.   (getter-with-setter (@ (guile) cddddr)
  164.                       (compose-setter set-cdr! (@ (guile) cdddr))))
  165.  
  166. (define string-ref
  167.   (getter-with-setter (@ (guile) string-ref)
  168.                       string-set!))
  169.  
  170. (define vector-ref
  171.   (getter-with-setter (@ (guile) vector-ref)
  172.                       vector-set!))
  173.  
  174. ;;; srfi-17.scm ends here
  175.